Poniższy kod działa tylko na mac os i ma sens jedynie gdy mamy niepolskie ustawienia dat i czasu a chcemy zmienić na polskie. W przypadku właściwych - polskich - ustawień nazwy dni i miesięcy powinny wyświetlać się nam po polsku. Jeśli nazwy są niepolskie kod zmieniający kolejność dni w punkcie o kalendarzach i mapach cieplnych nie będzie działał prawidłowo.
Według Dana Roama autora ksiażki “Narysuj swoje myśli” oś czasu jest modelem wizualnym ilustrującym odpowiedź na pytanie “kiedy” [@roam2010]. Najprościej stworzyć timeline używając funkcji geom_segment() ggplot2.
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.3 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ ggplot2 3.5.0 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.0
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
Użyjemy danych dotyczących dat publikacji i liczby słów w książkach z sag A. Sapkowskiego i G.R.R. Martina.
fantasy <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/fantasy.csv")
## New names:
## Rows: 12 Columns: 6
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (2): title, author dbl (4): ...1, number, rok, words
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`
fantasy <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/fantasy.csv")
## New names:
## Rows: 12 Columns: 6
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (2): title, author dbl (4): ...1, number, rok, words
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`
head(fantasy)
Poniższy wykres jest połączeniem wykresu lizakowego (lollypop chart) z osią czasu. Lizaki - słupki a właściwie odcinki zakończone punktem - oznaczać będą daty kolejnych książek
fantasy %>% filter(author == "Martin") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'open')) +
geom_segment(aes(x = rok,
y = words,
xend = rok),
yend = 0) +
geom_point(aes(x = rok,
y = words)) +
geom_text(aes(x = rok,
y = words,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
fantasy %>% filter(author == "Martin") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0)
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
fantasy %>% filter(author == "Martin") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0) +
#rysuję oś czasu
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,
y = disloc,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = disloc)) +
# kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
fantasy %>% filter(author == "Martin") %>%
# wysokość lizaków = liczba słow
ggplot() +
geom_segment(aes(x = rok,
y = words,
xend = rok),
yend = 0) +
#rysuję oś czasu
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,
y = words,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words)) +
# kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Etykiety na skali można także wybrać na podstawie danych:
sapkowski <- fantasy %>%
filter(author == "Sapkowski") %>%
mutate(disloc = c(0.5, 1, -0.5, -1, 2)) #mniej punktów bo saga Sapkowskiego jest krótsza
ggplot(sapkowski) +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0) +
#rysuję oś czasu
geom_segment(aes(x = 1990,
y = 0,
xend = 2003, #skracam oś czasu bo ostatnia książka jest z 1999
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,
y = disloc,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = disloc)) +
#kontroluje etykiety na skali ręcznie wybierając tylko lata publikacji książek wykorzystując dane w ramce
scale_x_continuous(breaks = sapkowski$rok) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2003, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 5 rows.
## ℹ Did you mean to use `annotate()`?
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,
units = 'cm'),
type = 'closed')) +
geom_text(aes(x = rok,y = words,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words,
color = author)) +
theme_minimal() +
theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,
units = 'cm'),
type = 'closed')) +
geom_text(aes(x = rok,y = words,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words,
color = author)) +
theme_minimal() +
theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Wykres panelowy.
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1993,y = 0,xend = 2012,yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,y = words,label = title), hjust = 0.5,vjust = - 0.5, size = 4) +
geom_point(aes(x = rok,
y = words)) +
scale_x_continuous(breaks = c(1994, 1995, 1996, 1997, 1999, 2000,2005, 2011)) +
scale_y_continuous(limits = c(0, 450000)) +
theme_bw() +
labs(y = "słowa") +
theme(axis.title.x = element_blank(), #usuwa podpis na osi x
#axis.title.y = element_blank(),
axis.text.y = element_blank(), # usuwa tekst etykiet na osi y
text = element_text(size = 15)) +
facet_wrap(~author, nrow =2)
## Warning in geom_segment(aes(x = 1993, y = 0, xend = 2012, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Prosty przykład ramki danych z datami w formie znakowej.
timeline_data <- data.frame(event = c("Event 1", "Event 2"),
start = c("2020-06-06", "2020-10-01"),
end = c("2020-10-01", "2020-12-31"),
group = "My Events")
Na poniższym wykresie widać problem z właściwą interpretacją dat w formie napisów:
timeline_data %>%
ggplot() +
geom_segment(aes(y = event, #potrzebujemy esetyk y, yend i analogizni z x
xend = end,
x= start,
yend = event)) +
theme_bw()
Dlatego zamienimy napisy na daty funkcją as.Date:
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = event,
xend = end,
x= start,
yend = event)) +
theme_bw()
Ponieważ w moim systeme daty ustawione są na amerykańskie zmieniam ustawienie na polskie.
Ten sam wykres będzie wyglądał inaczej.
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = event,
xend = end,
x= start,
yend = event,
color= event), linewidth = 15) +
theme_bw()
time <- timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end))
Gantt w jednej linii
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = group,
xend = end,
x= start,
yend = group,
colour = event)) +
scale_x_date() +
theme_bw()
Dane dotyczące długości trwania poszczególnych rządów w IIIRP za wikipedią:
premierzyIIIRP <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/premierzyIIIRP.csv")
## Rows: 22 Columns: 7
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (3): nazwisko, stronnictwo, stronnictwo2
## dbl (2): narodziny, śmierć
## date (2): start, end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
premierzyIIIRP <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/premierzyIIIRP.csv")
## Rows: 22 Columns: 7
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (3): nazwisko, stronnictwo, stronnictwo2
## dbl (2): narodziny, śmierć
## date (2): start, end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
View(premierzyIIIRP)
Jak widać w ostatniej komórce brakuje daty.
Dla uniknięcia problemów z rysowaniem linii można uzupełnić końcową komórkę w zmiennej end datą systemową funkcją Sys.Date, wewnątrz funkcji ymd z biblioteki lubridate. Komórka znajduje się w 7 kolumnie, w 22 wierszu więc robimy to tak:
premierzyIIIRP[22,7] <- lubridate::ymd(Sys.Date())
ggplot(premierzyIIIRP) +
geom_segment(aes(y = stronnictwo,
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo),
linewidth = 10) +
scale_x_date() +
theme_bw()
Uporządkujmy wykorzystując funkcję reorder:
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end),
linewidth = 15)) +
scale_x_date() +
theme_bw() -> wykres
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
library(plotly)
##
## Attaching package: 'plotly'
## The following object is masked from 'package:ggplot2':
##
## last_plot
## The following object is masked from 'package:stats':
##
## filter
## The following object is masked from 'package:graphics':
##
## layout
ggplotly(wykres, tooltip = "text")
plotly::ggplotly(z, tooltip = “text”)
Ustalmy etykiety na osi y na zakończenia kadencji (premierzyIIIRP$end).
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date(breaks = (premierzyIIIRP$end), # ustawiamy daty na osi x na koniec danego rządu
date_labels = "%Y") + #date_labels ustawione na rok
theme_bw() +
guides(colour = "none") # wyłączamy legendę
To nie jest dobre rozwiązanie bo daty się nakładają
Dlatego stworzymy wektor z unikalnymi datami rocznymi funkcjami unique i year.
kadencje <- unique(year(premierzyIIIRP$start))
Wektor który uzyskaliśmy ma format numeryczny.
class(kadencje)
## [1] "numeric"
Następnie zmienimy jego format na date
kadencje <- lubridate::ymd(kadencje,
truncated = 2L)
class(kadencje)
## [1] "Date"
plotly::ggplotly(ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
theme_bw() +
guides(colour = "none")
)
z <- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end))) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
plotly::ggplotly(z, tooltip = "text")
y <- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
y
plotly::ggplotly(y, tooltip = "text") # dodatmy tekst do argumntu tooltip
Dodamy premierów
y1<- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
geom_text(aes(y = reorder(stronnictwo, start),
x= start,
label = nazwisko)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
y1
library(ggrepel)
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
geom_text_repel(aes(y = reorder(stronnictwo, start),
x= start,
label = nazwisko)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw() +
theme(panel.grid.minor = element_blank())
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
library(scales)
##
## Attaching package: 'scales'
## The following object is masked from 'package:purrr':
##
## discard
## The following object is masked from 'package:readr':
##
## col_factor
library(lubridate)
#install.packages("timevis")
library(timevis)
data <- data.frame(
id = 1:4,
content = c("Item one", "Item two",
"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11",
"2016-01-20", "2016-02-14 15:00:00"),
end = c(NA, NA, "2016-02-04", NA)
)
timevis(data)
?timevis
premierzyIIIRP %>%
rename(content = nazwisko) %>%
rename(group = stronnictwo) %>% #argument groups i soubgroups pakitu timevis
timevis()
Użyjemy danych na temat sttrat sprzętu wojskowego w Ukrainie:
oryx <- read.csv("https://raw.githubusercontent.com/Tomasz-Olczyk/testowe-repozytrium/main/oryx.csv")
zajrzyjmy do danych:
glimpse(oryx)
## Rows: 664
## Columns: 2
## $ date <chr> "2022-02-24", "2022-02-25", "2022-02-26", "2022-02-27", "2022…
## $ change_3 <int> NA, 52, 55, 54, 160, 37, 112, 59, 93, 102, 94, 52, 75, 24, 40…
oryx$date jest wektorem napisów a oryx$change_3 liczb całkowitych z wartościami brakującymi
oryx %>%
mutate(date = as.Date(date)) %>%
complete(date = seq.Date(as.Date("2022-02-01"), #funkcja complete tworzy nowe obserwacje, funkcja seq.Date tworzy sekwencję dat
as.Date("2023-12-31"),
by="day")) %>%
mutate(month = month(date, label = TRUE),
wday = wday(date, label = TRUE),
day = day(date),
week = epiweek(date)) -> df1 #operator przypisania może działać także w drugą stronę
x1 <- df1 %>%
ggplot(aes(x = wday, y = week, text = paste('straty: ', change_3))) +
geom_tile(aes(fill = change_3), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Sprzęt utracony na Ukrainie przez Rosjan - dane Oryx",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank()) +
guides(color = "none")
## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
x1
Epiweek - tydzień zaczyna się od niedzieli:
?epiweek
Sprawdzamy kolejność dni:
levels(df1$wday)
## [1] "ndz" "pon" "wto" "śro" "czw" "ptk" "sob"
oryx %>%
mutate(date = as.Date(date)) %>%
filter(date < "2023-01-01") %>%
complete(date = seq.Date(as.Date("2022-02-01"), as.Date("2022-12-31"), by="day")) %>%
mutate(month = month(date, label = TRUE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date)) -> df2
df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
Kolejność dni w zmiennej czynnikowej wday musi być zmieniona bo isoweek zaczyna się w poniedziałk
df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
Sprawdzamy kolejność dni:
levels(df2$wday)
## [1] "pon" "wto" "śro" "czw" "ptk" "sob" "ndz"
x <- df2 %>%
ggplot(aes(x = wday, y = week, text = paste('straty: ', change_3))) +
geom_tile(aes(fill = change_3), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Sprzęt utracony na Ukrainie przez Rosjan - dane Oryx",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank()) +
guides(color = "none")
x
library(plotly)
ggplotly(x, tooltip = "text")
oryx %>%
mutate(date = as.Date(date)) %>%
#usunę filtrowani na roku
#filter(date < "2023-01-01") %>%
complete(date = seq.Date(as.Date("2022-01-01"), as.Date("2023-12-31"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date)) -> df2
isowek zaczyna się w poniedziałek:
df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
ggplot(df2, aes(y = fct_rev(wday), x= week, fill = change_3)) +
geom_tile(width =7, height = 1, colour = "white")
ggplot(df2, aes(y = fct_rev(wday),
x= week,
fill = change_3)) +
geom_tile(colour = "white") +
scale_fill_gradient(low = "#BAE177", high ="#155219",
na.value = "gray88")
ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#coord_equal sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
theme_minimal()
ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
theme_minimal() +
facet_wrap(~year, nrow =2)
ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
theme_minimal() +
facet_wrap(~year, nrow = 2)
miesiące = as.data.frame(table(df2$month))
(y <- ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =2.5, to = 52, by = 4.333),
labels = miesiące$Var1) +
theme_minimal() +
facet_wrap(~year, nrow = 2)
)
library(plotly)
ggplotly(y)
Stworzymy kalendarz wzorowany na kalendarzu aktywności na githubie.
Dane dotyczące ataków powietrznych na Ukrainę z Kaggle. Według opisu automatycznie ekstraktowane z komunikatów ukraińskich.
# zbiór missile_attacks z kaggle
ataki_rakietowe <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")
## Rows: 861 Columns: 10
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (7): time_start, model, launch_place, target, destroyed_details, carrie...
## dbl (2): launched, destroyed
## dttm (1): time_end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
#zbiór missiles_and_uav
środki <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missiles_and_uav.csv")
## Rows: 35 Columns: 9
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): model, category, national_origin, type, launch_platform, name, name...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
ataki_rakietowe <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")
## Rows: 861 Columns: 10
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (7): time_start, model, launch_place, target, destroyed_details, carrie...
## dbl (2): launched, destroyed
## dttm (1): time_end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
środki <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missiles_and_uav.csv")
## Rows: 35 Columns: 9
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): model, category, national_origin, type, launch_platform, name, name...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
Łączymy ramkę danych z ramką opisującą typy środków napadu powietrznego żeby wyselekcjonować ataki z użyciem wybranego typu.
Wybieram model i category z ramki środki:
środki_s <- środki %>%
select(model, category)
Wybieram czas, model, wystrzelone z ramki ataki:
ataki_s <- ataki_rakietowe %>%
select(time_end, model,launched, destroyed)
Łączę lewym złączeniem (left_join)
ataki_środki <- left_join(ataki_s, środki_s)
## Joining with `by = join_by(model)`
ataki_środki <- ataki_środki %>%
mutate(date = as.Date(time_end)) %>%
complete(date = seq.Date(as.Date("2022-01-01"),
as.Date("2024-03-31"),
by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date))
Sumy ataków według kategorii
ataki_cat <- ataki_środki %>%
group_by(date, category) %>%
summarise(wystrzelone = sum(launched)) %>%
ungroup()
## `summarise()` has grouped output by 'date'. You can override using the
## `.groups` argument.
manewrujące <- ataki_cat %>%
filter(category == "cruise missile") %>%
select(date, wystrzelone)
manewrujące %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::epiweek(date)) -> df7
ggplot(df7, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "orange",
high ="red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"),
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
balistyczne <- ataki_cat %>%
filter(category == "ballistic missile") %>%
select(date, wystrzelone)
balistyczne %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::epiweek(date)) -> bdf
b <- ggplot(bdf, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "orange",
high ="red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące$Var1,
position = "bottom") +
theme_gray() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
b <- ggplot(bdf, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "orange",
high ="red4",
na.value = "gray") + #
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące$Var1,
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
b
ggplotly(b)
## Warning in min(x): no non-missing arguments to min; returning Inf
## Warning in max(x): no non-missing arguments to max; returning -Inf
## Warning in matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), :
## data length [365] is not a sub-multiple or multiple of the number of rows [7]
## Warning in matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow =
## TRUE): data length [365] is not a sub-multiple or multiple of the number of rows
## [7]
## Warning in colorscale_json(trace$colorscale): A colorscale list must of elements
## of the same (non-zero) length
bdf %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_grid(year~month) +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank()) +
guides(color = "none")
levels(bdf$wday)
## [1] "ndz" "pon" "wto" "śro" "czw" "ptk" "sob"
balistyczne %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date)) -> bdf_iso
bdf %>%
filter(year == 2023) %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank()) +
guides(color = "none")
bdf_iso$wday <- factor(bdf_iso$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
bdf_iso$week[bdf_iso$month=="sty" & bdf_iso$week ==52] = 0
bdf_iso %>%
filter(year == 2023) %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank())
test <- bdf_iso %>%
filter(year == 2023,
months == 1)
test3 <- bdf %>%
filter(year == 2023,
months == 12)
test4 <- df2 %>%
filter(year == 2023,
months == 1)
epiweek(ymd("2022-01-01"))
## [1] 52
#install.packages("calendR")
library(calendR)
## ~~ Package calendR
## Visit https://r-coder.com/ for R tutorials ~~
# Data
set.seed(2)
data <- rnorm(365)
dat <- bdf %>%
filter(year == 2023) %>%
select(wystrzelone)
dat[is.na(dat)] <- 0
# Calendar
calendR(year = 2023,
special.days = dat$wystrzelone,
gradient = TRUE,
low.col = "#FCFFDD",
special.col = "#00AAAE",
legend.pos = "right",
legend.title = "Title")
stock.data <- transform(bdf,
tydz = as.POSIXlt(date)$yday %/% 7 + 1,
dz = as.POSIXlt(date)$wday,
yrok = as.POSIXlt(date)$year)
library(ggplot2)
ggplot(stock.data, aes(tydz, dz, fill = wystrzelone)) +
geom_tile(colour = "white") +
scale_fill_gradientn(colours = c("#D61818","#FFAE63","#FFFFBD","#B5E384")) +
facet_wrap(~ year, ncol = 1) +
coord_equal()
stock.data %>%
ggplot(aes(x = dz, y = tydz)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = dz)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_grid(year~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank())
qplot(week, Adj.Close, data = stock.data, colour = factor(wday), geom = “line”) + facet_wrap(~ year, ncol = 1)
df <- tibble(
DateCol = seq(
dmy("01/01/2022"),
dmy("31/12/2022"),
"days"
),
ValueCol = runif(365)
)
dfPlot <- df %>%
mutate(weekday = wday(DateCol, label = T, week_start = 7), # can put week_start = 1 to start week on Monday
month = month(DateCol, label = T),
date = yday(DateCol),
week = epiweek(DateCol))
# isoweek makes the last week of the year as week 1, so need to change that to week 53 for the plot
dfPlot$week[dfPlot$month=="sty" & dfPlot$week ==52] = 0
dfPlot <- dfPlot %>%
group_by(month) %>%
mutate(monthweek = 1 + week - min(week))
dfPlot %>%
ggplot(aes(weekday,-week, fill = ValueCol)) +
geom_tile(colour = "white") +
theme(aspect.ratio = 1/5,
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank(),
panel.grid = element_blank(),
axis.ticks = element_blank(),
panel.background = element_blank(),
strip.background = element_blank(),
strip.text = element_text(face = "bold", size = 15),
panel.border = element_rect(colour = "black", fill=NA, size=1)) +
facet_wrap(~month, nrow = 4, ncol = 3, scales = "free")
## Warning: The `size` argument of `element_rect()` is deprecated as of ggplot2 3.4.0.
## ℹ Please use the `linewidth` argument instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
sty <- dfPlot %>% filter(month == "sty")